QRZ! Ham Radio 5/QRZ Ham Radio Callsign Database - Volume 5.iso/files/packet/misc/pktmon12.lzh/PKTMON12.PAS

Pascal/Delphi Source File | 1992-06-23 | 30.1 KB | 1,062 lines

(*

   Packet Radio Monitor version 1.2
   author: Pawel Jalocha
           Rynek Kleparski 14/4a
           PL-31150 Krakow, Poland
   e-mail: [e-mail]
           [e-mail]
           [e-mail]

   This program may be freely used/copied/modified for non-commercial use.

   This program decodes HF and VHF packets.
   It uses HamComm (or similar) interface.

   The audio signal from a receiver in connected to one of the
   COM ports (DSR line) via 'Ham Comm' style interface which 'squares'
   audio signal by mean of a simple comparator. Comparator output
   steers RS232 DSR input.

   Each transition on DSR makes an interrupt. Interrupt service routine
   reads the system timer (8253) so to find out what time elapsed
   since previous transition. This way the program keeps track of
   the audio signal period, frequency and timing.

   Ones you have frequency it is possible to decode bits from it,
   find out X25 starting flag, build complete frames, etc...

   In HF mode the program is "hardwired" to 700 Hz center frequency.
   It is intended to be used with 500 Hz CW filter. Precise
   (better than 50 Hz) tuning is required

   In VHF mode it accepts FSK centered at 1700 Hz with deviation
   either 800 Hz or 1000 Hz.

   This program was written and compiled with Turbo Pascal 6.0 and tested
   on a 386SX/20MHz machine. I used COM2 port because mouse is sitting on
   my COM1. I never actually tried whether it works on COM1.
*)

program PacketMonitor(input,output);

uses Dos, Crt;

const BufferSize = $3FFF; (* must be 2^n-1 *)

type buffer = record
                        ReadPtr, WritePtr:word;
                Store: array [0..BufferSize] of word
              end;

{$S-}{$R-}
procedure InitBuffer(var b:buffer);
  begin
      b.ReadPtr:=0; b.WritePtr:=0
  end;

procedure IncBufferPtr(var p:word);
  begin
      inc(p); p:=p and BufferSize
  end;

procedure ReadBuffer(var buff:buffer; var w:word; var empty:boolean); assembler;
  asm
    push ds
      les di,empty
      mov dl,0ffh
      mov es:[di],dl
      lds si,buff
      mov ax,[si]; mov bx,si
      mov cx,[si+2]
      cmp ax,cx
      jz @Empt
        mov dl,0; mov es:[di],dl
        les di,w
        add si,4; add si,ax; add si,ax
        mov dx,[si]; mov es:[di],dx
        add ax,1; and ax,BufferSize; mov ds:[bx],ax
@Empt:
    pop ds
  end;

(* 'no asm' version of above procedure
procedure ReadBuffer(var b:buffer; var w:word; var empty:boolean);
  begin
    with b do
      begin
        if ReadPtr=WritePtr
          then empty:=true
          else
            begin
              empty:=false;
              w:=Store[ReadPtr];
              IncBufferPtr(ReadPtr)
            end
      end
  end;
*)

procedure WriteBuffer(var buff:buffer; w:word; var full:boolean); assembler;
  asm
    push ds
      les di,full
      mov dl,0FFh; mov es:[di],dl
      lds si,buff
      mov ax,[si]; add si,2; mov cx,[si]; mov bx,si; add si,2
      add si,cx; add si,cx
      add cx,1; and cx,BufferSize; cmp ax,cx
      jz @Ful
        mov dl,0; mov es:[di],dl
        mov dx,w; mov [si],dx
        mov [bx],cx
@Ful:
    pop ds
  end;

(* 'no asm' version of above routine
procedure WriteBuffer(var b:buffer; w:word; var full:boolean);
  var tmp:word;
  begin
    with b do
      begin
        tmp:=WritePtr; IncBufferPtr(tmp);
        if tmp=ReadPtr
          then full:=true
          else
            begin
              full:=false;
              Store[WritePtr]:=w;
              WritePtr:=tmp
            end
      end
  end;
*)
{$S+}{$R+}

procedure EnableInterrupts; inline($FB);

procedure DisableInterrupts; inline($FA);

const CommBase:word          = $2F8;  (* COM2 I/O base address *)
        IntMask:byte           = $08;   (* IRQ3 mask - bit 3 set *)
        IntNum:byte            = $0B;   (* IRQ3 service routine is INT 0B *)
        TimerBase              = $40;   (* 8253 timer I/O base address *)

procedure SelectCOM(com:integer; var ok:boolean);
  begin
    if com=1 then
      begin
        CommBase:=$3f8;
        IntMask:=$10;
        IntNum:=$0C;
        ok:=true;
      end
    else if com=2 then
      begin
        CommBase:=$2f8;
        IntMask:=$08;
        IntNum:=$0B;
        ok:=true
      end
    else writeln('COM',com,' not supported');
  end;

Procedure ReadTimer(var time:word); assembler;
  asm
    xor al,al
    out TimerBase+3,al
    in al,TimerBase; xchg al,ah
    in al,TimerBase; xchg al,ah
    les di,time
    mov es:[di],ax
  end;

var PrevTime:word;
    LostSamples:word;

var PeriodBuffer:Buffer;

{$S-}{$R-}
procedure DeltaInterrupt(fl,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp:word); Interrupt;
  var time:word; full:boolean;
  begin
    port[$20]:=$20;
    if (port[CommBase+2] and 7) = 0 then  (* check if modem status interrupt pending *)
      if (port[CommBase+6] and 2) <> 0 then (* check if DSR changed state *)
        begin
          (* ReadTimer(time); *)
      asm
        xor al,al
        out TimerBase+3,al
        in al,TimerBase; xchg al,ah
        in al,TimerBase; xchg al,ah
        mov time,ax
      end;
          WriteBuffer(PeriodBuffer,(PrevTime-time) shr 1,full);
          if full then inc(LostSamples);
          PrevTime:=time
        end
  end;
{$S+}{$R+}

procedure InitTimer; (* Is this routine really needed ? *)
  begin
(*
      DisableInterrupts;
      port[TimerBase+3]:=$36;
      port[TimerBase]:=0; port[TimerBase]:=0;
      EnableInterrupts
*)
  end;

procedure InitComm; (* Initialize communication port *)
  begin
      DisableInterrupts;
      port[CommBase+3]:=$03;
      port[CommBase+3]:=$83; Port[CommBase]:=$60; port[CommBase+1]:=$00;
      port[CommBase+3]:=$03; (* Base+1 as int. control *)
      port[CommBase+1]:=$00; (* Disable all interrupts *)
      port[CommBase+4]:=$09; (* DTR=high, RTS=low, OUT2=high (?) *)
      EnableInterrupts;
  end;

var OldIntVec:pointer;

procedure ConnectInterrupt; (* Connect & enable COM interrupt *)
  begin
      ReadTimer(PrevTime); LostSamples:=0;
      DisableInterrupts;
      GetIntVec(IntNum,OldIntVec);
      SetIntVec(IntNum,addr(DeltaInterrupt));
      port[$21]:=port[$21] and (not IntMask); (* Enable IRQ 3/4 in 8259 *)
      port[CommBase+1]:=$08; (* Enable 8250 interrupt on modem status change *)
      EnableInterrupts
  end;

procedure DisconnectInterrupt; (* Disable & disconnect COM interrupt *)
  begin
      DisableInterrupts;
      port[CommBase+1]:=$00;           (* Disable all 8250 interrupts *)
      port[$21]:=port[$21] or IntMask; (* Disable IRQ 3/4 in 8259 *)
      SetIntVec(IntNum,OldIntVec);     (* Change INT B/C vector *)
      EnableInterrupts
  end;

(* ======================================================================== *)

procedure OpenOld(var log:text; name:string);
  begin
    Assign(log,name);
    If FSearch(name,'')=''
      then
        begin
          (* writeln('Creating file ',name); *)
          Rewrite(log)
        end
      else
        begin
          (* writeln('ConLog will be appended to file ',name); *)
          Append(log)
        end
  end;

var ConLog:text;

procedure OpenConLog(name:string);
  begin
    Assign(ConLog,name);
    If FSearch(name,'')=''
      then
        begin
          (* writeln('Creating file ',name); *)
          Rewrite(ConLog)
        end
      else
        begin
          (* writeln('ConLog will be appended to file ',name); *)
          Append(ConLog)
        end
  end;

procedure CloseConLog;
  begin
    close(ConLog)
  end;

(* ======================================================================== *)
(* ======================================================================== *)

function HexDigit(b:byte):char;
  begin
    if b<10 then HexDigit:=chr(48+b)
    else if b<16 then HexDigit:=chr(65-10+b)
    else HexDigit:=' '
  end;

procedure WriteHexByte(var log:text; b:byte);
  begin
    Write(log,HexDigit(b shr 4));
    Write(log,HexDigit(b and $F))
  end;

function TwoDigits(w:word):string;
  var tmp:string[2];
  begin
    str(w:2,tmp); if tmp[1]=' ' then tmp[1]:='0';
    TwoDigits:=tmp;
  end;

procedure WriteTime(var log:text);
  var h,m,s,ss:word;
  begin
    GetTime(h,m,s,ss);
    write(log,TwoDigits(h),':',TwoDigits(m),':',TwoDigits(s));
  end;

procedure WriteDate(var log:text);
  var y,m,d,w:word;
  begin
    GetDate(y,m,d,w);
    write(log,y:4,'-',TwoDigits(m),'-',TwoDigits(d));
  end;


type ConnPtr = ^ConnRec;
     ConnRec = record
                 sour_dest:string[16];
                 seq:byte;
                 log:text; logname:string[20];
                 next:ConnPtr;
                 activ:integer;
               end;

var ConnRoot:ConnPtr;
    LogFileName:string[40];
    LogFileSeq:word;
    OthLogFile:text;

function FindConn(sour_dest:string):ConnPtr;
  var ptr:ConnPtr;
  begin
    ptr:=ConnRoot;
    while (ptr<>nil) and (ptr^.sour_dest<>sour_dest) do
      ptr:=ptr^.next;
    FindConn:=ptr
  end;

procedure AppendData(sour,dest:string; FrameSeq:byte; data:string);
  var SourDest:string[16]; ptr:ConnPtr; name:string[60];
      dseq:byte;
  begin
    SourDest:=sour+dest;
    ptr:=FindConn(SourDest);
    if ptr=nil
      then
        begin
          new(ptr);
          with ptr^ do
            begin
              next:=ConnRoot; ConnRoot:=ptr;
              str(LogFileSeq,name); name:=LogFileName+'.'+name; inc(LogFileSeq);
              sour_dest:=SourDest;
              writeln('Openning file ',name,' for traffic ',sour,' => ',dest);
              logname:=name; OpenOld(log,logname);
              write(log,'****** File open at '); WriteTime(log);
              write(log,' on '); WriteDate(log);
              writeln(log,' for ',sour,' => ',dest,' traffic');
              seq:=FrameSeq; write(log,data);
              activ:=5
            end
        end
      else
        with ptr^ do
          begin
            dseq:=((16+FrameSeq)-seq) and 7;
            if dseq=1
              then
                begin
                  write(log,data);
                  seq:=FrameSeq;
                  activ:=5
                end
              else if (dseq>0) and (dseq<=4) then
                begin
                  writeln('seq:',seq,'->',FrameSeq,'=>',dseq-1,' frames lost !!!');
                  write(log,' [',dseq-1,' lost pkts] ');
                  write(log,data);
                  seq:=FrameSeq;
                  activ:=5
                end;
          end
  end;

procedure OpenFrameAnalyze(Name:string);
  begin
    ConnRoot:=nil; LogFileSeq:=0; LogFileName:=Name;
    OpenOld(OthLogFile,LogFileName+'.oth');
    Rewrite(OthLogFile);
    write(OthLogFile,'****** File open at '); WriteTime(OthLogFile);
    write(OthLogFile,' on '); WriteDate(OthLogFile);
    writeln(OthLogFile,' for non-categorized data packets');
  end;

procedure PrintFrame(var log:text); forward;

procedure AnalyzeDataFrame(sour,dest:string; ctrl,pid:byte; data:string);
  var seq:byte;
  begin
    (* writeln(sour,'=>',dest,' seq=',(ctrl shr 1) and 7,' ',length(data),' bytes'); *)
    if (pid=$F0) and ((ctrl and 1) = 0) then
      begin
        seq:=(ctrl shr 1) and 7;
        AppendData(sour,dest,seq,data);
      end
    else if ctrl=$03 then
      (* writeln(data) *) PrintFrame(OthLogFile);
  end;

procedure AnalyzeCtrlFrame(sour,dest:string; ctrl:byte);
  begin
(*
    write(sour,'=>',dest);
    if ctrl=$3f then writeln(' connect request')
    else if ctrl=$53 then writeln(' disconnect request')
    else if (ctrl and $F)=1 then writeln(' Rx Ready for seq=',ctrl shr 5)
    else
      begin
        write(' Ctrl:');
        WriteHexByte(output,ctrl);
        writeln
      end
*)
  end;

procedure CloseConn(con:ConnPtr);
  begin
    writeln('Closing file ',con^.logname);
    with con^ do
      begin
        writeln(log);
        write(log,'****** File closed at '); WriteTime(log);
        write(log,' on '); WriteDate(log);
        close(log)
      end;
    dispose(con);
  end;

procedure CloseFrameAnalyze;
  var ptr,nptr:ConnPtr;
  begin
    ptr:=ConnRoot;
    while ptr<>nil do
      begin
        nptr:=ptr^.next; CloseConn(ptr); ptr:=nptr;
      end;
    ConnRoot:=nil;
    write(OthLogFile,'****** File closed at '); WriteTime(OthLogFile);
    write(OthLogFile,' on '); WriteDate(OthLogFile); Writeln(OthLogFile);
    close(OthLogFile)
  end;

procedure CheckActivity;
  var prev:^ConnPtr; con,ncon:ConnPtr;
  begin
    prev:=@ConnRoot; con:=ConnRoot;
    while con<>nil do
      begin
        if con^.activ<=0
          then
            begin
              ncon:=con^.next;
              prev^:=ncon;
              writeln(con^.log);
              writeln(con^.log,'****** connection inactive for 5 minutes');
              CloseConn(con); con:=ncon;
            end
          else
            begin
              writeln('File ',con^.logname,' activ=',con^.activ);
              if con^.activ>0 then dec(con^.activ);
              prev:=@con^.next; con:=con^.next;
            end
      end
  end;

(* ======================================================================== *)

const MaxFrameLen = 1024;

var LogBad,SortTraffic:boolean;

var FrameBuff:array [0..MaxFrameLen-1] of byte;
    FramePtr:word; BitCount:word; ByteReg:word;
    ConsBits:word; BadFrame:boolean;
    FrameCount,GoodFrames,CRCErrors:longint;

(* The following table & CRC computing routine is taken form PMP package *)

const CRCTable:array[0..255] of word = (
        0,  4489,  8978, 12955, 17956, 22445, 25910, 29887,
    35912, 40385, 44890, 48851, 51820, 56293, 59774, 63735,
     4225,   264, 13203,  8730, 22181, 18220, 30135, 25662,
    40137, 36160, 49115, 44626, 56045, 52068, 63999, 59510,
     8450, 12427,   528,  5017, 26406, 30383, 17460, 21949,
    44362, 48323, 36440, 40913, 60270, 64231, 51324, 55797,
    12675,  8202,  4753,   792, 30631, 26158, 21685, 17724,
    48587, 44098, 40665, 36688, 64495, 60006, 55549, 51572,
    16900, 21389, 24854, 28831,  1056,  5545, 10034, 14011,
    52812, 57285, 60766, 64727, 34920, 39393, 43898, 47859,
    21125, 17164, 29079, 24606,  5281,  1320, 14259,  9786,
    57037, 53060, 64991, 60502, 39145, 35168, 48123, 43634,
    25350, 29327, 16404, 20893,  9506, 13483,  1584,  6073,
    61262, 65223, 52316, 56789, 43370, 47331, 35448, 39921,
    29575, 25102, 20629, 16668, 13731,  9258,  5809,  1848,
    65487, 60998, 56541, 52564, 47595, 43106, 39673, 35696,
    33800, 38273, 42778, 46739, 49708, 54181, 57662, 61623,
     2112,  6601, 11090, 15067, 20068, 24557, 28022, 31999,
    38025, 34048, 47003, 42514, 53933, 49956, 61887, 57398,
     6337,  2376, 15315, 10842, 24293, 20332, 32247, 27774,
    42250, 46211, 34328, 38801, 58158, 62119, 49212, 53685,
    10562, 14539,  2640,  7129, 28518, 32495, 19572, 24061,
    46475, 41986, 38553, 34576, 62383, 57894, 53437, 49460,
    14787, 10314,  6865,  2904, 32743, 28270, 23797, 19836,
    50700, 55173, 58654, 62615, 32808, 37281, 41786, 45747,
    19012, 23501, 26966, 30943,  3168,  7657, 12146, 16123,
    54925, 50948, 62879, 58390, 37033, 33056, 46011, 41522,
    23237, 19276, 31191, 26718,  7393,  3432, 16371, 11898,
    59150, 63111, 50204, 54677, 41258, 45219, 33336, 37809,
    27462, 31439, 18516, 23005, 11618, 15595,  3696,  8185,
    63375, 58886, 54429, 50452, 45483, 40994, 37561, 33584,
    31687, 27214, 22741, 18780, 15843, 11370,  7921,  3960 );

{$R-}{$S-}
function ComputeCRC:word;
  var p,crc,t:word;
  begin
    crc:=$FFFF;
    for p:=0 to FramePtr-1-2 do
      begin
        t:=FrameBuff[p] xor (crc and $FF);
        crc:=hi(crc) xor CRCTable[t]
      end;
    ComputeCRC:=not crc;
  end;

function GetCRC:word;
  begin
    GetCRC:=FrameBuff[FramePtr-2] or (FrameBuff[FramePtr-1] shl 8)
  end;

procedure OpenFrame;
  begin
    (* write('=> '); *)
    FramePtr:=0; BitCount:=0; ByteReg:=0; ConsBits:=0; BadFrame:=false
  end;

procedure AddBitToFrame(bit:boolean);

  procedure AddBit(b:word);
    begin
      ByteReg:=(ByteReg shr 1) or b;
      inc(BitCount);
      if((BitCount and 7) = 0) then
        if FramePtr<MaxFrameLen then
          begin
            FrameBuff[FramePtr]:=lo(ByteReg);
            inc(FramePtr)
          end
        else BadFrame:=true
    end;

  begin
    if not BadFrame then
      begin
        (* write(ord(bit):2); *)
        if bit
          then AddBit($80)
          else if ConsBits<5 then AddBit($00);
        if bit
          then inc(ConsBits)
          else ConsBits:=0;
        if ConsBits>5 then
          begin
            (* write('<BS!>'); *)
            BadFrame:=true
          end
      end;
  end;

procedure PrintFrameAddress(var log:text; var Ctrl:word);
  var p,l:word;
  begin
    (* write(log,'Addr: '); *)
    p:=0;
    while (p<FramePtr-2) and ((FrameBuff[p] and 1)=0) do inc(p);
    Ctrl:=p+1;
    p:=0;
    while p+7<=Ctrl do
      begin
        for l:=1 to 6 do
          begin
            write(log,chr(FrameBuff[p] shr 1));
            inc(p)
          end;
        write(log,'-',HexDigit((FrameBuff[p] shr 1) and $F));
        if FrameBuff[p]>=$80 then write(log,'R ') else write(log,'  ');
        inc(p)
      end;
    if p<>Ctrl then write(log,'!') else write(log,' ')
  end;

procedure PrintFrame(var log:text);
  var b:word; ch:char; ctrl:byte;
  begin
    (* write(ConLog,' [',FramePtr,'] '); *)
    WriteTime(log); write(log,' => ');
    PrintFrameAddress(log,b);
    if b<=FramePtr-1-2 then
      begin
        ctrl:=FrameBuff[b];
              write(log,' Ctrl:'); WriteHexByte(log,ctrl); inc(b);
        if (ctrl and $F)=1 then
                  write(log,' [Rx Ready for seq ',ctrl shr 5,']')
        else if (ctrl and 1) = 0 then
                  write(log,' [Data, seq ',(ctrl shr 1) and 7,']')
        else if ctrl = 3 then
                  write(log,' [UnAck Info]')
        else if ctrl = $3F then
                  write(log,' [Connect Request]')
            end;
    if b<=FramePtr-1-2 then
      begin
              write(log,' Pid:'); WriteHexByte(log,FrameBuff[b]); inc(b)
            end;
    Writeln(log);
    if b<FramePtr-2 then
      begin
        Write(log,' Data: ');
        for b:=b to FramePtr-1-2 do
          begin
            ch:=chr( FrameBuff[b] );
            if (ch>=' ') (* and (ch<chr(127)) *)
              then
                if ch='#' then write(log,'##')
                          else write(log,ch)
              else
                begin
                  write(log,'#');
                  WriteHexByte(log,FrameBuff[b])
                end
          end;
        writeln(log)
      end
  end;

procedure GetFrameAddress(var ctrl:word; var sour,dest:string);
  var p:word;
  begin
    for p:=0 to 5 do dest[p+1]:=chr(FrameBuff[p] shr 1);
    dest[7]:='-'; dest[8]:=HexDigit( (FrameBuff[6] shr 1) and $F);
    dest[0]:=#8;
    for p:=7 to 12 do sour[p-6]:=chr(FrameBuff[p] shr 1);
    sour[7]:='-'; sour[8]:=HexDigit( (FrameBuff[13] shr 1) and $F);
    sour[0]:=#8;
    p:=0;
    while (p<FramePtr-2) and ((FrameBuff[p] and 1)=0) do inc(p);
    ctrl:=p+1;
    (* if (ctrl mod 7) <> 0 then write('!!') *)
  end;

procedure AnalyzeFrame;
  var b:word; ch:char;
      sour,dest:string[8]; ctrl,pid:byte; data:string[255];
  begin
    GetFrameAddress(b,sour,dest);
    if b<=FramePtr-1-2 then
      begin Ctrl:=FrameBuff[b]; inc(b) end;
    if b<=FramePtr-1-2
      then
        begin
          pid:=FrameBuff[b]; inc(b);
          data:=''; for b:=b to FramePtr-1-2 do data:=data+chr(FrameBuff[b]);
          AnalyzeDataFrame(sour,dest,ctrl,pid,data);
        end
      else
        AnalyzeCtrlFrame(sour,dest,ctrl)
  end;

procedure CloseFrame;
  begin
    if FramePtr>=17 then inc(FrameCount)
                    else BadFrame:=true;
    (* if (FramePtr=0) and (BitCount=0) then write('='); *)
    if (BitCount and $7)<>0 then
      begin
        (* write('<BC:',BitCount and 7,'>'); *)
(*
        if LogBad then
          begin
            PrintFrame; Writeln('^^^ Number of bit not a multiple of 8 !!!');
          end;
*)
        BadFrame:=true;
      end;
    if not BadFrame then
      begin
        If ComputeCRC = GetCRC
          then
            begin
              PrintFrame(ConLog);
                            if SortTraffic then AnalyzeFrame;
                            inc(GoodFrames)
            end
          else
            begin
             inc(CRCErrors);
             if LogBad then
               begin
                 PrintFrame(ConLog); writeln(ConLog,'^^^ CRC failed !!!')
               end
            end
      end
    else if (FramePtr>=16) and (FramePtr<=255) then
      begin
        (* write('B!'); PrintFrame *)
      end
  end;

const TimerFreq:longint = 1193180;

var reg:word; ByteSync:byte;
    PrevBit:boolean;

procedure InitAnalyze;
  begin
    reg:=0; ByteSync:=0;
    OpenFrame; BadFrame:=true;
    FrameCount:=0; GoodFrames:=0; CRCErrors:=0;
    PrevBit:=false;
  end;

procedure AnalyzeBit(bit:boolean);
  begin
    if Bit xor PrevBit
      then reg:=(reg shl 1)
      else reg:=(reg shl 1) or 1;
    PrevBit:=Bit;
    if ByteSync>0 then dec(ByteSync)
                  else AddBitToFrame( (reg and $100) <> 0 );
    if lo(reg)=$7E then
      begin
        CloseFrame; OpenFrame; ByteSync:=8
        (* write('<F>') *)
      end
  end;

(* ======================================================================== *)

(* ======================================================================== *)

const FilterFIFOLen=63; (* must be 2^n-1 *)

var FilterPerFIFO:array [0..FilterFIFOLen] of word;
    FIlterLevFIFO:array [0..FilterFIFOLen] of boolean;
    FilterFIFORdPtr,FilterFIFOWrPtr:word; FilterSum:word;
    FilterSampling:word; FilterSamplingPhase:word;
    FilterTimeLen:word; CorrThreshold:word;

var Sample_1,Sample_2:integer;
    Level_1,Level_2:boolean;
    SampleBitNow:boolean;
    SyncStep:word;

var SampleAver,InterSampleAver:integer;

procedure FilterInit(len,sampling:word);
  begin
    FilterFIFORdPtr:=0;
    FilterPerFIFO[0]:=len; FilterLevFIFO[0]:=false;
    FilterFIFOWrPtr:=1;
    FilterSum:=0;

    FilterSampling:=sampling; FilterSamplingPhase:=FilterSampling;
    FilterTimeLen:=len; CorrThreshold:=len shr 1;

    Sample_1:=0; Sample_2:=0;
    Level_1:=false; Level_2:=false;
    SampleBitNow:=false;
    SyncStep:=len shr 3;

    SampleAver:=0; InterSampleAver:=0;
  end;

procedure FilterInput(Level:boolean; Len:word);
  begin
    FilterPerFIFO[FilterFIFOWrPtr]:=Len;
    FilterLevFIFO[FilterFIFOWrPtr]:=Level;
    FilterFIFOWrPtr:=(FilterFIFOWrPtr+1) and FilterFIFOLen;
    if FilterFIFOWrPtr=FilterFIFORdPtr then writeln('Fatal: Filter FIFO overloaded !');
    if Level then inc(FilterSum,Len);
    while Len>0 do
      begin
        if Len<FilterPerFIFO[FilterFIFORdPtr]
          then
            begin
              dec(FilterPerFIFO[FilterFIFORdPtr],Len);
              if FilterLevFIFO[FilterFIFORdPtr] then dec(FilterSum,Len);
              Len:=0;
            end
          else
            begin
              dec(Len,FilterPerFIFO[FilterFIFORdPtr]);
              if FilterLevFIFO[FilterFIFORdPtr] then dec(FilterSum,FilterPerFIFO[FilterFIFORdPtr]);
              FilterFIFORdPtr:=(FilterFIFORdPtr+1) and FilterFIFOLen;
            end
      end
  end;

function FilterFIFOuse:word;
  var diff:integer;
  begin
    diff:=FilterFIFOWrPtr-FilterFIFORdPtr;
    if diff>=0
      then FilterFIFOuse:=diff
      else FilterFIFOuse:=FilterFIFOLen+1+diff
  end;

const SyncConst=8; SyncConst2=4;

procedure FilterNextSample(Signal:word);
  var Sample:integer; Level:boolean; diff,lim:integer;
  begin
    Sample:=Signal-CorrThreshold; Level:=sample>0;
    if SampleBitNow
      then
        begin
          SampleAver:=SampleAver + (10*abs(Sample_1)-SampleAver+16) div 32;
          AnalyzeBit(Level_1);
        end
      else
        begin
          if Level_2 xor Level then
            begin
              diff:=Sample_1; if Level then diff:=-diff;
              InterSampleAver:=InterSampleAver
                            + (10*Sample_1-InterSampleAver+16) div 32 ;
                            if diff>=SyncConst then
                              FilterSamplingPhase:=FilterSamplingPhase+((diff) div SyncConst2)
              else if diff<=-SyncConst then
                              FilterSamplingPhase:=FilterSamplingPhase-((-diff) div SyncConst2)
              else if diff>0
                              then inc(FilterSamplingPhase)
              else if diff<0 then
                              dec(FilterSamplingPhase);
            end;
        end;
    SampleBitNow:=not SampleBitNow;
    Sample_2:=Sample_1; Level_2:=Level_1;
    Sample_1:=Sample;   Level_1:=Level
  end;

procedure FilterPreInput(Level:boolean; Len:word);
  begin
    while Len>0 do
      begin
        if Len<FilterSamplingPhase
          then
            begin
              FilterInput(Level,Len);
              dec(FilterSamplingPhase,Len);
              Len:=0;
            end
          else
            begin
              FilterInput(Level,FilterSamplingPhase);
              dec(Len,FilterSamplingPhase);
              FilterSamplingPhase:=FilterSampling;
              FilterNextSample(FilterSum);
            end
      end
  end;

(* ======================================================================== *)

const ModemFIFOLen=31; (* must be 2^n-1 *)
var ModemFIFO:array [0..ModemFIFOLen] of word;
    ModemFIFORdPtr,ModemFIFOWrPtr:word; ModemFIFOTrans:word;

procedure DelayModemInit(delay:word);
  begin
    ModemFIFORdPtr:=0; ModemFIFO[0]:=delay; ModemFIFOWrPtr:=1;
    ModemFIFOTrans:=1;
  end;

procedure DelayModemInput(period:word);
  var FirstPer:word;
  begin
    ModemFIFO[ModemFIFOWrPtr]:=period;
    ModemFIFOWrPtr:=(ModemFIFOWrPtr+1) and ModemFIFOLen;
    if ModemFIFOWrPtr=ModemFIFORdPtr then writeln('Fatal: Modem FIFO overloaded !');
    inc(ModemFIFOTrans);
    while period>0 do
      begin
        if period<ModemFIFO[ModemFIFORdPtr]
          then
            begin
              FilterPreInput((ModemFIFOTrans and 1)=0,period);
              dec(ModemFIFO[ModemFIFORdPtr],period); period:=0;
            end
          else
            begin
              FilterPreInput((ModemFIFOTrans and 1)=0,ModemFIFO[ModemFIFORdPtr]);
              dec(period,ModemFIFO[ModemFIFORdPtr]);
              ModemFIFORdPtr:=(ModemFIFORdPtr+1) and ModemFIFOLen;
              dec(ModemFIFOTrans);
            end
      end
  end;

function DelayModemFIFOuse:word;
  var diff:integer;
  begin
    diff:=ModemFIFOWrPtr-ModemFIFORdPtr;
    if diff>=0
      then DelayModemFIFOuse:=diff
      else DelayModemFIFOuse:=ModemFIFOLen+1+diff
  end;

(* ======================================================================== *)
  const tune:string[19]='                   ';
        ampl:string[10]='          ';

procedure DisplayTune;
  var OldX,OldY:byte; freq:word; bin:integer; amp:word;
  begin
    amp:=SampleAver div CorrThreshold;
    if amp>9 then amp:=9;
    bin:=(InterSampleAver div (CorrThreshold div 4));
        if bin>9 then bin:=9 else if bin<-9 then bin:=-9;
    ampl[1+amp]:=chr(48+amp); tune[10-bin]:=chr(48+abs(bin));
    OldX:=WhereX; OldY:=WhereY;
    TextAttr:=TextAttr xor $77;
    GotoXY(42,1); write('A ',ampl,' A');
    GotoXY(58,1); write('T ',tune,' T');
    TextAttr:=TextAttr xor $77;
    GotoXY(OldX,OldY);
    ampl[amp+1]:=' '; tune[10-bin]:=' ';
  end;

var period:word; empty,stop :boolean;  key:char;
    com,mode:integer; ok:boolean; delay,width,sampl:word;
    yes_no:char; ConLogName:string[40]; SortedLogName:string[40];

    NextMinute,hour,min,sec,hsec:word;

begin
  ClrScr;
  writeln('Packet Radio Decoder 1.20 by P.J.');
  writeln;

  write('COM 1 or 2 ? '); readln(com);
  SelectCOM(com,ok);
  if not ok then exit;

  writeln; writeln('Packet type:');
  writeln('1.  HF packet.  700 Hz center, +/- 100 Hz dev.');
  writeln('2. VHF packet. 1700 Hz center, +/- 400 Hz dev.');
  writeln('3. VHF packet. 1700 Hz center, +/- 500 Hz dev.');
  write('? 1/2/3 '); readln(mode);
  case mode of
    1: begin delay:=400; width:=350; sampl:=600; end;
    2: begin delay:=1360; width:=1133; sampl:=2400; end;
    3: begin delay:=2266; width:=1133; sampl:=2400; end;
  else
    begin
      writeln('Not supported mode'); exit
    end
  end;

  writeln; write('Log bad packets ? (y/n) ');
  yes_no:=ReadKey;
  case yes_no of
    'y','Y':begin
              LogBad:=true;
              writeln('will log packets with bad CRC');
            end;
    'n','N':begin
              LogBad:=false;
              writeln('will NOT log bad packets');
            end;
  else
    begin
      writeln(' ... will not log bad packets');
      LogBad:=false;
    end;
  end;

  writeln;
  write('File to log all packets [RETURN for console log] ? ');
    Readln(ConLogName);
  if ConLogName='' then ConLogName:='con';

  writeln;
  writeln('File to log sorted packet traffic');
    writeln('Give the name only - no extension. Example: c:\log_dir\pktmon');
  writeln('If you enter empty string sorting will be disabled');
  write('? '); Readln(SortedLogName);
  SortTraffic:=not (SortedLogName='');

  writeln;
  writeln('Press RETURN to terminate');

  GetTime(hour,min,sec,hsec);
  NextMinute:=min+2; if NextMinute>=60 then dec(NextMinute,60);

  OpenConLog(ConLogName);

  writeln(ConLog);
  write(ConLog,'Started Logging on '); WriteDate(ConLog);
  write(ConLog,' at '); WriteTime(ConLog); writeln(ConLog);
  if SortTraffic then OpenFrameAnalyze(SortedLogName);

  InitTimer; InitComm; InitBuffer(PeriodBuffer);

  DelayModemInit(round(TimerFreq/delay));
  FilterInit(round(TimerFreq/width),round(TimerFreq/sampl));
  InitAnalyze;

  ConnectInterrupt;
  stop:=false;
  repeat
      repeat
        ReadBuffer(PeriodBuffer,period,empty);
        if not empty
            then DelayModemInput(period)
      until empty;
    GetTime(hour,min,sec,hsec);
    if min=NextMinute then
      begin
        if SortTraffic then
                  begin
            writeln('Checking activity...'); CheckActivity
          end;
        NextMinute:=min+1; if NextMinute>=60 then NextMinute:=0;
      end;
    (* if mode=1 then *) DisplayTune;
    if KeyPressed then
      begin
        key:=Readkey;
        case key of
          #13:stop:=true;
        end;
      end;
  until stop;

  DisconnectInterrupt;
  writeln(ConLog,FrameCount,' total frames received and ',GoodFrames,' good ones + ',CRCErrors,' CRC errors');
  write(ConLog,'Stopped logging on '); WriteDate(ConLog);
  write(ConLog,' at '); WriteTime(ConLog); writeln(ConLog);
  if SortTraffic then CloseFrameAnalyze; CloseConLog;
end.